home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / ISSUE05 / CALLBAX / PROGRESU.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-12-06  |  3.7 KB  |  150 lines
  1. unit Progresu;
  2.  
  3. interface
  4.  
  5. uses
  6.   ThunkU, SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs, StdCtrls, Grids, DBGrids, DB, DBTables, DbiTypes,
  8.   DbiProcs;
  9.  
  10. const
  11.   wm_GenProgress = wm_User + 58;
  12.  
  13. type
  14.   TForm1 = class(TForm)
  15.     Table1: TTable;
  16.     DataSource1: TDataSource;
  17.     DBGrid1: TDBGrid;
  18.     FillBtn: TButton;
  19.     CopyBtn: TButton;
  20.     Table2: TTable;
  21.     DBGrid2: TDBGrid;
  22.     DataSource2: TDataSource;
  23.     EmptyBtn: TButton;
  24.     QueryBtn: TButton;
  25.     Query1: TQuery;
  26.     procedure FormDestroy(Sender: TObject);
  27.     procedure FormCreate(Sender: TObject);
  28.     procedure EmptyBtnClick(Sender: TObject);
  29.     procedure FillBtnClick(Sender: TObject);
  30.     procedure CopyBtnClick(Sender: TObject);
  31.     procedure QueryBtnClick(Sender: TObject);
  32.   private
  33.     { Private declarations }
  34.     FOldCallBack: TCallBack;
  35.     FProgressBuf: CBProgressDesc;
  36.     FProgressFunctionThunk: TFarProc;
  37.   public
  38.     { Public declarations }
  39.     procedure WMGenProgress(var Msg: TMessage); message wm_GenProgress;
  40.   end;
  41.  
  42. var
  43.   Form1: TForm1;
  44.  
  45. implementation
  46.  
  47. {$R *.DFM}
  48. {$S-}
  49.  
  50. function ProgressFunction(ecbType: CBType; iClientData: Longint;
  51.   var CbInfo: Pointer): CBRType; export;
  52. begin
  53.   Result := cbrUseDef;
  54.   if ecbType = cbGenProgress then
  55.     Result := CBRType(SendMessage(Application.MainForm.Handle,
  56.       wm_GenProgress, 0, Longint(@Form1.FProgressBuf)));
  57.   with Form1.FOldCallBack do
  58.     if ChainedFunc <> nil then Result :=
  59.       pfDBICallBack(ChainedFunc)(cbGenProgress, Data, Buffer)
  60. end;
  61.  
  62. procedure TForm1.FormCreate(Sender: TObject);
  63. begin
  64.   try
  65.     Table1.Exclusive := True;
  66.     Table1.Open;
  67.     Table2.Exclusive := True;
  68.     Table2.Open;
  69.   except
  70.     on EDatabaseError do
  71.       MessageDlg('Can''t find those tables', mtError, [mbOk], 0);
  72.   end;
  73.   FProgressFunctionThunk := NewMakeProcInstance(@ProgressFunction, HInstance);
  74.   with FOldCallBack do
  75.     DbiGetCallBack(nil, cbGenProgress, Data, BufLen, Buffer, @ChainedFunc);
  76.   DbiRegisterCallBack(nil, cbGenProgress, 0, SizeOf(FProgressBuf),
  77.     @FProgressBuf, pfDbiCallBack(FProgressFunctionThunk));
  78. end;
  79.  
  80. procedure TForm1.FormDestroy(Sender: TObject);
  81. begin
  82.   DbiRegisterCallBack(nil, cbGenProgress, 0, 0, nil, nil);
  83.   NewFreeProcInstance(FProgressFunctionThunk);
  84. end;
  85.  
  86. procedure TForm1.WMGenProgress(var Msg: TMessage);
  87. var
  88.   Progress: String;
  89. begin
  90.   with pCBProgressDesc(Msg.LParam)^ do
  91.     if iPercentDone <> -1 then
  92.       Progress := IntToStr(iPercentDone)
  93.     else
  94.       Progress := StrPas(szMsg);
  95. {$define INTERACTIVE}
  96. {$ifdef INTERACTIVE}
  97.   case MessageDlg(Progress + '. Continue?', mtConfirmation, [mbYes, mbNo], 0) of
  98.     mrYes: Msg.Result := Longint(cbrContinue);
  99.     mrNo: Msg.Result := Longint(cbrAbort);
  100.   end;
  101. {$else}
  102.   Caption := Progress;
  103. {$endif}
  104. end;
  105.  
  106. procedure TForm1.EmptyBtnClick(Sender: TObject);
  107. begin
  108.   Table1.EmptyTable;
  109.   Table2.EmptyTable;
  110. end;
  111.  
  112. procedure TForm1.FillBtnClick(Sender: TObject);
  113. var
  114.   Loop: Longint;
  115. const
  116.   NumRecs = 5000;
  117. begin
  118.   Screen.Cursor := crSQLWait;
  119.   with Table1 do
  120.   begin
  121.     DisableControls;
  122.     for Loop := RecordCount + 1 to RecordCount + NumRecs do
  123.     begin
  124.       Append;
  125.       Fields[0].AsInteger := Random(High(SmallInt));
  126.       Fields[1].AsInteger := Random(High(SmallInt));
  127.       Post;
  128.       Caption := 'Adding record ' + IntToStr(Loop) + ' of ' + IntToStr(NumRecs);
  129.     end;
  130.     First;
  131.     EnableControls;
  132.   end;
  133.   Screen.Cursor := crDefault;
  134.   Caption := 'Copy the table to see the callback';
  135. end;
  136.  
  137. procedure TForm1.CopyBtnClick(Sender: TObject);
  138. begin
  139.   Table2.BatchMove(Table1, batAppend);
  140.   Table1.First;
  141. end;
  142.  
  143. procedure TForm1.QueryBtnClick(Sender: TObject);
  144. begin
  145.   Query1.Close;
  146.   Query1.Open;
  147. end;
  148.  
  149. end.
  150.